home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / product.arc / ACAD.LSP next >
Encoding:
Text File  |  1980-01-04  |  16.3 KB  |  478 lines
  1. (Vmon)  ;Virtual Memory On 
  2.  
  3. ;These are the functions in ACAD.LSP:
  4. ;    1.  Find  (find) 
  5. ;    2.  Import  (import) 
  6. ;    3.  Export  (export) 
  7. ;    4.  Text Fit  (tfit) 
  8. ;    5.  Change Text Size Global (tszg) 
  9. ;    6.  Change Text Size Select (tsz) 
  10. ;    7.  Fillet 2 circles  (filetcir) 
  11. ;    8.  Increment Number Individual (number) 
  12. ;    9.  Change Text (ct) 
  13. ;   10.  Delete Layer (dl) 
  14. ;   11.  Delete All (da) 
  15. ;   12.  Drawing Setup (setup) 
  16. ;   13.  Parts List (plist) 
  17. ;   14.  Weld arrow up (wldf) 
  18. ;   15.  Weld arrow down (wldn) 
  19. ;   16.  Part identifier (balloonc) 
  20. ;   17.  Ortho Rectangle (r) 
  21. ;   18.  Reset Drawing Scale (orsc) 
  22. ;   19.  Error: 
  23. ;   20.  Breakout 
  24.  
  25. ;1.  Counts the number of objects in a drawing.
  26. ;    They could be entities or blocks. 
  27. (Defun C:Find (/ A B C) 
  28.        (Setvar "Cmdecho" 0) 
  29.        (Setq A (Getstring "\nObject name to be found: ")) 
  30.        (Setq B 0) 
  31.        (Setq C (Entnext)) 
  32.        (While C 
  33.               (Cond ((= (Strcase A) (Cdr (Assoc 0 (Entget C)))) 
  34.                      (Setq B (1+ B))) 
  35.                     ((= (Strcase A) (Cdr (Assoc 2 (Entget C)))) 
  36.                      (Setq B (1+ B))) 
  37.               ) 
  38.               (Setq C (Entnext C)) 
  39.        ) 
  40.        (Prompt "\nThere are ")  
  41.        (Prompt (Itoa B)) 
  42.        (Prompt " occurances of ") 
  43.        (Prompt (Strcase A)) (Prompt "\n") 
  44. ) 
  45.  
  46. ;2.  Imports an ASCII text file into the current drawing. 
  47. (Defun C:Import (/ P1 A B C D E F) 
  48.        (Setvar "Cmdecho" 0) 
  49.        (Prompt "Developed by: Applied Technical Support -
  50. Tulsa\n") 
  51.        (Setq A (Getstring "Enter the ASCII text file name: ")) 
  52.        (Setq B (Getreal "Enter the text height: ")) 
  53.        (Setq C (Getreal "Enter the line spacing: ")) 
  54.        (Setq D (Getstring "Enter the justification, LCR <L>: ")) 
  55.        (Setq P1 (Getpoint "Enter the insertion point of first
  56. text line: ")) 
  57.        (Setq E (Open A "r")) 
  58.        (Setq F (Read-line E)) 
  59.        (If (= D "") (Setq D nil)) 
  60.        (While (Or nil F) 
  61.               (If (null D) 
  62.                   (Command "Text" P1 B 0 F) 
  63.                   (Command "Text" D P1 B 0 F) 
  64.               ) 
  65.               (Setq P1 (List (Car P1) (- (Cadr P1) C))) 
  66.               (Setq F (Read-line E)) 
  67.        ) 
  68. ) 
  69.  
  70. ;3.  Export - takes notes off a drawing and places them into 
  71. ;    an ASCII file. 
  72. (Defun C:Export (/ A B C D E F G H I) 
  73.        (Setvar "Cmdecho" 0) 
  74.        (Setq A (Getstring "Enter the file name: ")) 
  75.        (Setq B (Open A "r")) 
  76.        (If (/= B nil) 
  77.            (Progn 
  78.                  (Prompt "File already exists.\n") 
  79.                  (Close B) 
  80.            ) 
  81.            (Progn 
  82.                  (Setq C (Open A "w")) 
  83.                  (Prompt "\nFile now open") 
  84.                  (Prompt "\nPick items in order to write to
  85. file") 
  86.                  (Setq D 0) 
  87.                  (Setq E (Ssget)) 
  88.                  (Setq F (Sslength E)) 
  89.                  (Repeat F 
  90.                           (Setq G (Ssname E D)) 
  91.                           (Setq H (Entget G)) 
  92.                           (Setq I (Cdr (Assoc 1 H))) 
  93.                           (Write-line I C) 
  94.                           (Setq D (+ 1 D)) 
  95.                  ) 
  96.                  (Close C) 
  97.            ) 
  98.        ) 
  99. ) 
  100.  
  101. ;4.  Text Fit - Squeezes and moves existing text. 
  102. (Defun C:Tfit (/ P1 P2 P3 A B C D) 
  103.        (Setvar "Cmdecho" 0) 
  104.        (Setq A (Entsel "\nSelect insertion point of text to fit:
  105. ")) 
  106.        (Setq A (Car A)) 
  107.        (Setq B (Entget A)) 
  108.        (Setvar "Orthomode" 1) 
  109.        (Setq P1 (Cdr (Assoc 10 B))) 
  110.        (Setq P2 (Getdist P1 "\nTouch end of text: ")) 
  111.        (Setq P1 (Getpoint "\nEnter new 1st point: ")) 
  112.        (Setq P3 (Getpoint P1 "\nEnter 2nd point: ")) 
  113.        (Setq C (Assoc 41 B)) 
  114.        (Setq D (* (/ (Distance P1 P3) P2) (Cdr C))) 
  115.        (Setq D (Cons 41 D)) 
  116.        (Setq B (Subst D C B)) 
  117.        (Setq P1 (Cons 10 P1)) 
  118.        (Setq P3 (Cons 11 P3)) 
  119.        (Setq C (Assoc 10 B)) 
  120.        (Setq B (Subst P1 C B)) 
  121.        (Setq C (Assoc 11 B)) 
  122.        (Entmod (Subst P3 C B)) 
  123.        (Setq A nil) 
  124. ) 
  125.  
  126. ;5.  Globally changes text from one height to another. 
  127. (Defun C:Tszg (/ A B C D E F G) 
  128.        (Setvar "Cmdecho" 0) 
  129.        (Setq A (Getreal "\nEnter text size to change: ")) 
  130.        (Setq B (Fix (* 100 A))) 
  131.        (Setq C (Getreal "\nEnter new text height: ")) 
  132.        (Setq D (Entnext)) 
  133.        (Setq E (Cons 40 C)) 
  134.        (Setq F (Assoc 40 (Entget D))) 
  135.        (While D 
  136.                (Setq F (Assoc 40 (Entget D))) 
  137.                (If (/= nil F) 
  138.                    (Setq G (Fix (* 100 (Cdr F)))) 
  139.                ) 
  140.                (If (= B G) 
  141.                    (Entmod (Subst E F (Entget D))) 
  142.                ) 
  143.                (Setq D (Entnext D)) 
  144.        ) 
  145. ) 
  146.  
  147. ;6.  Changes selected text from one height to another. 
  148. (Defun C:Tsz (/ A B C D E F) 
  149.        (Setvar "Cmdecho" 0) 
  150.        (Setq A (Ssget)) 
  151.        (Setq B (Sslength A)) 
  152.        (Setq C (Getreal "\nEnter new text size: ")) 
  153.        (While (> B 0) 
  154.               (Setq B (1- B)) 
  155.               (Setq D (Ssname A B)) 
  156.               (Setq D (Entget D)) 
  157.               (Setq E (Assoc 40 D)) 
  158.               (Setq F (Cons 40 C)) 
  159.               (Entmod (Setq D (Subst F E D))) 
  160.        ) 
  161.        (Setq A nil) 
  162. ) 
  163.  
  164. ;7.  Fillets the outside radius between two circles. 
  165. (Defun C:Filetcir (/ A B C D E F G H I) 
  166.        (Setvar "Cmdecho" 0) 
  167.        (Setvar "Blipmode" 0) 
  168.        (Setq A (Osnap (Getpoint "\nMark first arc: ")"Nea")) 
  169.        (Setq B (Osnap (Getpoint "\nMark second arc: ")"Nea")) 
  170.        (Setq C (Getdist "\nFillet radius: ")) 
  171.        (Setq D (Osnap A "Cen")) 
  172.        (Setq E (Distance A D)) 
  173.        (Setq F (Osnap B "Cen")) 
  174.        (Setq G (Distance B F)) 
  175.        (Setq H (Distance D F)) 
  176.        (Setq I (+ (* H H) 
  177.                (- (* (- C E) (- C E))(* (- C G) (- C G)))) 
  178.        ) 
  179.        (Setq A (* 2 (- C E) H)) 
  180.        (Setq B (* (- C E) (/ I A))) 
  181.        (Setq A (Sqrt (- (* (- C E) (- C E)) (* B B)))) 
  182.        (Setq B (Polar F (Angle F D) (- H B))) 
  183.        (Setq A (Polar B (- (Angle F D) (/ Pi 2)) A)) 
  184.        (Setq B (+ (Angle F A) Pi)) 
  185.        (Setq C (+ (Angle D A) Pi)) 
  186.        (Setvar "Blipmode" 1) 
  187.        (Command "Arc" (Polar D C E) "C" A (Polar F B G)) 
  188. ) 
  189.  
  190. ;8.  Increments numbers while the user 
  191. ;    randomly places them around the screen. 
  192. (Defun C:Numbers (/ A B C D E) 
  193.        (Setvar "Cmdecho" 0) 
  194.        (Setq A (Getint "\nEnter first number of series: ")) 
  195.        (Setq B (Getint "\nEnter last number of series: ")) 
  196.        (Setq C (Getreal "\nEnter text height: ")) 
  197.        (Setq D (Getreal "\nText rotation <0>: " )) 
  198.        (If (= D nil) 
  199.            (Setq D 0) 
  200.        ) 
  201.        (While (<= A B) 
  202.               (Setq E (Getpoint "\nLocation of number: ")) 
  203.               (Command "Text" E C D A) 
  204.               (Setq A (+ A 1)) 
  205.        ) 
  206. ) 
  207.  
  208. ;9. Changes text.  Corrects spelling errors 
  209. (defun c:ct (/ p l n e os as ns st s nsl osl sl si chf chm) 
  210.         (Setvar "Cmdecho" 0) 
  211.         (setq p (ssget)) 
  212.         (if p (progn 
  213.            (setq osl (strlen (setq os 
  214.                          (getstring "\nOld string: " t)))) 
  215.            (setq nsl (strlen (setq ns 
  216.                          (getstring "\nNew string: " t)))) 
  217.            (setq l 0) 
  218.            (setq chm 0) 
  219.            (setq n (sslength p)) 
  220.            (while (< l n) 
  221.               (if (= "TEXT" 
  222.                      (cdr (assoc 0 
  223.                        (setq e (entget (ssname p l)))))) 
  224.                  (progn 
  225.                     (setq chf nil) 
  226.                     (setq s (cdr (setq as (assoc 1 e)))) 
  227.                     (setq si 1) 
  228.                     (while (= osl (setq sl (strlen 
  229.                                   (setq st (substr s si osl))))) 
  230.                        (if (= st os) (progn 
  231.                           (setq s (strcat (substr s 1 (1- si)) ns
  232.  
  233.                                           (substr s (+ si osl))))
  234.  
  235.                           (setq chf t) 
  236.                        )) 
  237.                        (setq si (1+ si)) 
  238.                     ) 
  239.                     (if chf (progn 
  240.                        (setq e (subst (cons 1 s) as e)) 
  241.                        (entmod e) 
  242.                        (setq chm (1+ chm)) 
  243.                     )) 
  244.                  ) 
  245.               ) 
  246.               (setq l (1+ l)) 
  247.            ) 
  248.         )) 
  249.         (princ "Changed ") 
  250.         (princ chm) 
  251.         (princ " text lines.") 
  252.         (terpri) 
  253. ) 
  254.  
  255. ;10.  deletes layers. 
  256. (Defun C:Dl (/ A B) 
  257.        (Setvar "Cmdecho" 0) 
  258.        (Setq A (Strcase (Getstring "\nEnter layer to delete: ")))
  259.  
  260.        (Setq B (Entnext)) 
  261.        (While B 
  262.               (If (= A (Cdr (Assoc 8 (Entget B)))) 
  263.                   (Entdel B) 
  264.               ) 
  265.               (Setq B (Entnext B)) 
  266.        ) 
  267. ) 
  268.  
  269. ;11.  Deletes all. 
  270. (Defun C:Da (/ A) 
  271.        (Setvar "Cmdecho" 0) 
  272.        (Setq A (Entnext)) 
  273.        (While A 
  274.               (Entdel A) 
  275.               (Setq A (Entnext A)) 
  276.        ) 
  277. ) 
  278.  
  279. :12.  Drawing scale setup. 
  280. (Defun C:Setup (/ A B C D E F) 
  281.        (Setvar "Cmdecho" 0) 
  282.        (Setq A nil) 
  283.        (Setq B "Wrong paper size") 
  284.        (Command "Dscale") 
  285.        (Setq DS (Getreal "\nEnter drawing scale (1, 2, 4, 12, 48, etc.): ")) 
  286.        (Prompt "\nAvailable paper sizes are AH AV B C D E") 
  287.        (Setq A (Strcase (Getstring "\nEnter letter of paper size:"))) 
  288.        (Setvar "Userr1" DS) 
  289.        (Setvar "Cmdecho" 0) 
  290.        (If (= A "AH") (Setq C (List 12 9))) 
  291.        (If (= A "AV") (Setq C (List 9 12))) 
  292.        (If (= A "B") (Setq C (List 18 12))) 
  293.        (If (= A "C") (Setq C (List 24 18))) 
  294.        (If (= A "D") (Setq C (List 36 24))) 
  295.        (If (= A "E") (Setq C (List 48 36))) 
  296.        (If (= A nil) (*error* B)) 
  297.        (Setq D (Car C)) 
  298.        (Setq E (Cadr C)) 
  299.        (Setvar "Regenmode" 0) 
  300.        (Command "Dim" "Dimscale" DS "Exit") 
  301.        (Command "Limits" (List (* DS -1) (* DS -1)) (List (* DS
  302. D) (* DS E))) 
  303.        (Command "Grid" DS) 
  304.        (Command "Snap" (/ DS 4)) 
  305.        (Command "Ltscale" DS) 
  306.        (If (= A "AH")(Command "Insert" "Tshtah" (List 0 0) DS ""
  307. "0")) 
  308.        (If (= A "AV")(Command "Insert" "Tshtav" (List 0 0) DS ""
  309. "0")) 
  310.        (If (= A "B")(Command "Insert" "Tshtb" (List 0 0) DS ""
  311. "0")) 
  312.        (If (= A "C")(Command "Insert" "Tshtc" (List 0 0) DS ""
  313. "0")) 
  314.        (If (= A "D")(Command "Insert" "Tshtd" (List 0 0) DS ""
  315. "0")) 
  316.        (If (= A "E")(Command "Insert" "Tshte" (List 0 0) DS ""
  317. "0")) 
  318.        (Setvar "Regenmode" 1) 
  319.        (Command "Zoom" "A") 
  320.        (Setq F (* 0.125 DS)) 
  321.        (Setvar "Textsize" F) 
  322. ) 
  323.  
  324. ;13.  Draws a parts list and prompts for the  
  325. ;     parts. 
  326. (Defun C:Plist (/ P1 P2 P3 P4 P5 A1 A B C D E F) 
  327.        (Setvar "Cmdecho" 0) 
  328.        (Setq F (Getvar "Blipmode")) 
  329.        (Setvar "Blipmode" 0) 
  330.        (prompt "\n ********* BE SURE YOU HAVE RUN SETUP!! ******")
  331.        (prompt "\n ********* Just Type SETUP ******")
  332.        (Setq A (Getvar "userr1")) 
  333.        (Setq B (Getint "\nEnter number of items in list: ")) 
  334.        (Setq P1 (Osnap (Getpoint "\nTouch upper right corner of
  335. drawing: ") 
  336.                  "End") 
  337.        ) 
  338.        (Command "Insert" "Plist" P1 (/ A 1) "" "0") 
  339.        (Setq P1 (List (- (Car P1) (* 0.34375 A)) (- (Cadr P1) (*
  340. 0.31250 A)))) 
  341.        (Setq P2 (List (- (Car P1) (* 5.09375 A)) (Cadr P1))) 
  342.        (Setq P3 (List (- (Car P2) (* 1.00 A)) (Cadr P2))) 
  343.        (Setq P4 (List (- (Car P3) (* 0.4375 A)) (Cadr P3))) 
  344.        (Setq P5 (List (- (Car P4) (* 0.625 A)) (+ (Cadr P4) (*
  345. 0.3125 A)))) 
  346.        (Setq A1 (* 1.5 Pi)) (Setq D (* 0.25 A)) 
  347.        (Setq E (+ (* 0.3125 A) (* D B))) 
  348.        (Command "Line" P1 (Polar P1 A1 E) "") 
  349.        (Command "Line" P2 (Polar P2 A1 E) "") 
  350.        (Command "Line" P3 (Polar P3 A1 E) "") 
  351.        (Command "Line" P4 (Polar P4 A1 E) "") 
  352.        (Command "Line" P5 (Polar P5 A1 (+ (* 0.6250 A) (* D B)))
  353. "") 
  354.        (Setq P1 (Polar P5 A1 (* 0.875 A))) 
  355.        (Command "Line" P1 (Polar P1 0 (* 7.5 A)) "") 
  356.        (Command "Array" "L" "" "R" B "" (* -1 D)) 
  357.        (Setq P1 (List (+ (Car P1) (* 0.3125 A)) (+ (Cadr P1) (*
  358. 0.0625 A)))) 
  359.        (Setq P2 (Polar P1 0 (* 0.53125 A))) 
  360.        (Setq P3 (Polar P2 0 (* 0.71875 A))) 
  361.        (Setq P4 (Polar P3 0 (* 0.5625 A))) 
  362.        (Setq P5 (Polar P4 0 (* 5.203125 A))) 
  363.        (Setq C 1) 
  364.        (Repeat B 
  365.                (Command "Text" "C" P1 (* 0.125 A) "0" (Itoa C)) 
  366.                (Prompt "\nQuantity for item ") 
  367.                (Princ C) 
  368.                (Prompt ": ") 
  369.                (Setq G (Read-line)) 
  370.                (Command "Text" "C" P2 (* 0.125 A) "0" G) 
  371.                (Prompt "\nPart number for item ") 
  372.                (Princ C) (Prompt ": ") (Setq G (Read-line)) 
  373.                (Command "Text" "C" P3 (* 0.125 A) "0" G) 
  374.                (Prompt "\nDescription for item ") 
  375.                (Princ C) (Prompt ": ") (Setq G (Read-line)) 
  376.                (Command "Text" P4 (* 0.125 A) "0" G) 
  377.                (Prompt "\nDrawing size for item ") 
  378.                (Princ C) (Prompt ": ") (Setq G (Read-line)) 
  379.                (Command "Text" P5 (* 0.125 A) "0" G) 
  380.                (Setq P1 (List (Car P1) (- (Cadr P1) D))) 
  381.                (Setq P2 (List (Car P2) (- (Cadr P2) D))) 
  382.                (Setq P3 (List (Car P3) (- (Cadr P3) D))) 
  383.                (Setq P4 (List (Car P4) (- (Cadr P4) D))) 
  384.                (Setq P5 (List (Car P5) (- (Cadr P5) D))) 
  385.                (Setq C (+ 1 C)) 
  386.        ) 
  387.        (Setvar "Blipmode" F) 
  388. ) 
  389.  
  390.  
  391. ;14.  Draws a weld arrow. 
  392. (Defun C:Wldf (/ P1 P2 A) 
  393.        (Setvar "Cmdecho" 0) 
  394.        (Setq DS (Getreal "\nEnter the Dimscale: ")) 
  395.        (Setq P1 (Getpoint "\nFrom point: ")) 
  396.        (Setq P2 (Getpoint "\nTo point: ")) 
  397.        (If (<= (Car P2) (Car P1)) 
  398.            (Setq A "Weldupr") (Setq A "Weldupl") 
  399.        ) 
  400.       (Command "Layer" "S" "4" "") 
  401.       (Command "Dim1" "Leader" P1 P2 "" "") 
  402.       (Command "Insert" A P2 DS "" "0") 
  403. ) 
  404.  
  405. ;15.  Draws a weld arrow. 
  406. (Defun C:Wldn (/ P1 P2 A) 
  407.        (Setvar "Cmdecho" 0) 
  408.        (Setq DS (Getreal "\nEnter the Dimscale: ")) 
  409.        (Setq P1 (Getpoint "\nFrom point: ")) 
  410.        (Setq P2 (Getpoint "\nTo point: ")) 
  411.        (If (<= (CAR P2) (CAR P1)) 
  412.            (Setq A "Welddnr") (Setq A "Welddnl") 
  413.        ) 
  414.        (Command "Layer" "S" "4" "") 
  415.        (Command "Dim1" "Leader" P1 P2 "" "") 
  416.        (Command "Insert" A P2 DS "" "0") 
  417. ) 
  418.  
  419. ;16.  Draws part identifier - a balloon containing a  
  420. ;     number, then a leader to the object. 
  421. (Defun C:Balloonc (/ P1 P2 P3 P4 A) 
  422.        (Setq DS (Getreal "\nEnter the Dimscale: ")) 
  423.        (Setvar "Cmdecho" 0) 
  424.        (Setq P1 (Getpoint "\nFrom point: ")) 
  425.        (Setq P2 (Getpoint "\nTo point: ")) 
  426.        (If (<= (Car P2) (Car P1)) 
  427.            (Setq A (* -0.25 DS)) (Setq A (* 0.25 DS)) 
  428.        ) 
  429.        (Setq P3 (List (+ (Car P2) A) (Cadr P2))) 
  430.        (Setq P4 (List (+ (Car P3)(/ A 2)) (Cadr P3))) 
  431.        (Command "Layer" "S" "4" "") 
  432.        (Command "Dim1" "Leader" P1 P2 P3 "" "") 
  433.        (Setq A "Cballoon") 
  434.        (Command "Insert" A P4 DS "" "0") 
  435. ) 
  436.  
  437. ;17.  Draws an orthangonal retangle with PLINE. 
  438. (Defun C:R (/ P1 P2) 
  439.        (Setvar "Cmdecho" 0) 
  440.        (Setq P1 (Getpoint "\nEnter first corner: ")) 
  441.        (Setvar "Lastpoint" P1) 
  442.        (Setq P2 (Getpoint "\nEnter second corner: ")) 
  443.        (Command "Pline" P1 (List (Car P1) (Cadr P2)) 
  444.                            P2 (List (Car P2) (Cadr P1)) "C" 
  445.        ) 
  446. ) 
  447.  
  448. ;18.  Resets dimscale and user variable 1. 
  449. (Defun C:Orsc  ( / A B) 
  450.        (Setvar "Cmdecho" 0) 
  451.        (Setq B (Getvar "Userr1")) 
  452.        (Prompt "\nPresent drawing scale is <") 
  453.        (Prompt (Rtos B)) 
  454.        (Prompt ">") 
  455.        (Setq A (Getreal "\nEnter new drawing scale: ")) 
  456.        (Setvar "Userr1" A) 
  457.        (Command "Dim" "Dimscale" (Getvar "Userr1") "Exit") 
  458. ) 
  459.  
  460. ;19. Error. 
  461. (Defun *error* (st) 
  462.   (Princ "Error: ") 
  463.   (Princ st) 
  464.   (Terpri)) 
  465.  
  466. ;20.  Breakout. 
  467. (Defun C:Breakout (/ P1 P2 P3 A B) 
  468.        (Setvar "Cmdecho" 0) 
  469.        (Setq P1 (Osnap (Getpoint "\nPick first intersection:
  470. ")"Int,End")) 
  471.        (Setq P2 (Osnap (Getpoint "\nPick second intersection:
  472. ")"Int,End")) 
  473.        (Setq A (/ (+ (Car P1) (Car P2)) 2)) 
  474.        (Setq B (/ (+ (Cadr P1) (Cadr P2)) 2)) 
  475.        (Setq P3 (Osnap (List A B) "Near")) 
  476.        (Command "Break" P3 "F" P1 P2) 
  477. ) 
  478.